perm filename MUS2.F4[P11,LCS]1 blob
sn#583818 filedate 1981-05-02 generic text, type T, neo UTF8
C***** MUS2.F4 *******
C***** SCANR, LNEND, BARS, SCAN2, SCAN3, SCAN4
C ***** MSS SCANNER ******* SCN/FOR *********
SUBROUTINE SCANR
DIMENSION IQ(10),LRUD(4)
COMMON /ALF/INP(72),ML
COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
1 /JCHAR/IXX,ISEMI,JBLA,IG
COMMON /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
EQUIVALENCE (IQ(1),VX(41)),(VX1,VX(1)),(VX2,VX(2)),(LDN,LRUD(4))
1,(KSLA,JALPHA(28)),(ISTAR,JALPHA(8)),(ICOM,JALPHA(1)),
1(MINUS,JALPHA(2)),(IPLUS,JALPHA(7)),(IDOT,JALPHA(3))
DATA LRUD/'L','R','U','D'/
C FOR LEFT, RIGHT, UP, DOWN, EDIT
NNUM=-1
ISKP=0
JJ=0
XMINUS=1.
C LEAVES BLANK WHEN REST.
999 IDEC=99
M=0
2799 N=INP(ML)
899 ML=ML+1
781 IF(N.EQ.KSLA)N=ISEMI
C FOR MOTIVIC TRANFORMATIONS
IF(N.EQ.ISTAR)GO TO 751
IF(N.EQ.ISEMI)GO TO 751
C '*' AND '/' ADDED ABOVE 4/18/73
IF(N.NE.LXX)GO TO 22
IF(JN)GO TO 22
IF(ISKP.EQ.0)GO TO 210
ML=ML-1
GO TO 202
22 IF(N.EQ.IBLA)GO TO 4702
IF(N.NE.ICOM)GO TO 510
4702 IF(ISKP)202,2799,2799
4 IF(K.LT.19)GO TO 2799
IF(K.GT.20)GO TO 2799
CALL SCAN2(QZ)
C SCAN2 IS FOR METER, STEM DIR., STAFF UP-DN
IF(QZ)2799,512,4002
512 ML=ML+1
IF(INP(ML).EQ.ISEMI)RETURN
GO TO 512
510 IF(JN.GE.0)GO TO 173
C SKIP(JN=+1) IF NOT COMING FROM 'EDIT'
JN=1
DO 702 K=1,4
702 IF(N.EQ.LRUD(K))GO TO 703
C FINDS L, R, U, D
IF(N.GT.IBLA)GO TO 899
C GO TO 703 IF REALLY A LETTER, ELSE MOVE UP POINTER
703 JJ=JJ+1
C YOU CAN TYPE THE FULL WORD
IF(K.NE.4)GO TO 77
IF(INP(ML).EQ.LEE)K=99
C 'DE'=DELETE
77 IF(N.EQ.LEE)K=55
C 'E'= EDIT
IF(N.EQ.LCC)K=2222
IF(N.EQ.LXX)K=222
C 'C'=COPY, 'X'=EXIT FROM EDIT MODE
VX(JJ)=K
704 IF(INP(ML).EQ.JBLA)GO TO 2799
IF(INP(ML).GT.0)GO TO 2799
C IF NEXT CHAR. IS A LETTER(NEG.), SKIP IT.
C PUT COMMA ERASER IN SCX.
ML=ML+1
C SO IT WILL SKIP 'D' AND 'EL' IN 'EDIT' AND 'DEL'
GO TO 704
173 K=NALF(N)
IF(N.GT.0)GO TO 1410
IF(K.EQ.18)GO TO 73
C JUMP IF A REST OR OTHER R'S
IF(MODE.EQ.2)GO TO 144
C ;YOU CAN TYPE 'S', ETC., FOR SIXTEENTH ETC., RHYTHM.
C ; JUMP IF NOT A LETTER
C notes = 1xyz.0 x=accidental, yz=note num., negative=chord note
C rest = 2xyz.0 z=0=ordinary, =1=invis., =2=whole, =3=repeat bar
C =4=down, =5=up, -2xyz=num. of meas. rest
C clefs = 3xyz.0 z=0=treble, =1=bass, =2=alto, =3=tenor, neg.=invis.
C use TRE,BAS,ALT,TEN for clefs with no change to note levels.(4,5,6,7)
C bars = 4xyz.0 z=num. of staves up, neg.=dbl.bar
C ksig = 17xyz.0 z=num. of accis., pos.=#, neg.=b, x=1 for naturals.
C meter = 18xyz.n xy=top num, zn=bottom num (DONE IN SCMSS)
C stem = 5xyz.0 YZ=10=stem up, =20=stem down
C staff = 5xyz.0 z=0=return to norm., =1=lower stf., =2=upper stf.
IF(K.LT.8)GO TO 15
C JUMP IF A POSSIBLE NOTE
IF(K.NE.11)GO TO 16
C JUMP IF NOT A KSIG
CALL SCAN4
RETURN
C NOW LOOK FOR 'I'
16 IF(K.NE.9)GO TO 2
VX(1)=22.
C FOR EDIT I21 ETC.
GO TO 2799
C NOW 'M'
2 IF(K.NE.13)GO TO 3
CALL BARS
C ***** BARS =4000 ******
GO TO 512
3 IF(K.GT.16)GO TO 4
C JUMP IF NOT FOR 'PROXIMITY' MODE
NSWCH=K-15
GO TO 2799
C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
CXX4 IF(SCAN2(QZ))2799,4002,512
15 N=INP(ML)
IF(K.NE.2)GO TO 5
C CAIN K,2 ;IF(1ST LETR.NE.'B')GO TO S5
IF(N.NE.LAA)GO TO 5
C JUMP IF NOT BASS CLEF
QZ=3001.
C MOVE 02,[3001.0] ;BASS CLEF=3001
4002 N=INP(ML+1)
C GET 3RD CHAR.
IF(N.EQ.JBLA.OR.N.EQ.'/'.OR.N.EQ.ISEMI)GO TO 5002
C IF 3RD CHAR IS SIGNIFICANT THEN SPECIAL CLEF
C 4,5,6,7 = 0,1,2,3 BUT NO INFLUENCE ON NOTE LEVEL
QZ=QZ+4.
ML=ML+1
5002 VX(1)=QZ
51 IF(XMINUS.LT.0)VX(1)=-VX(1)
C TYPE '-BA' FOR INVISIBLE BASS CLEF, ETC.
GO TO 512
5 IF(N.NE.LEL)GO TO 6
C JUMP IF NOT ALTO CLEF
QZ=3002.0
GO TO 4002
6 CALL SCAN3(NSWCH)
4410 IF(INP(ML).EQ.ISEMI)RETURN
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
GO TO 310
210 JJ=JJ+1
IF(JJ.EQ.1)GO TO 3310
XMINUS=1.
VX(JJ)=0
C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
GO TO 310
C JUMP IF A LETTER
1410 IF(N.NE.MINUS)GO TO 544
XMINUS=-1.
IF(JJ.EQ.0)GO TO 2799
C -- FOR '-BA' ETC.
IF(MODE.EQ.1)GO TO 644
C [FOR AUTO OCT. SYS.]
GO TO 2799
544 IF(MODE.NE.1)GO TO 14
IF(N.NE.IPLUS)GO TO 14
644 VX4=7.
K=NALF(INP(ML))
IF(K.GT.9.OR.K.LT.0)GO TO 744
VX4=K
ML=ML+1
744 IF(N.NE.IPLUS)VX4=-VX4
GO TO 2799
C DEFAULT IS OCTAVE. (+ OR - 7)
144 CALL RHYLTR
C FOR INPUT OF RHYTHM WITH LETTERS - Q,E,S,W,G,H,D,T
GO TO 1310
14 ISKP=-1
IF(N.NE.IDOT)GO TO 79
IDEC=M
CXX DECI=M
GO TO 75
79 M=M+1
IQ(M)=NALF(N)
75 IF(N.EQ.ISEMI)GO TO 751
IF(INP(ML).NE.1)GO TO 2799
751 IF(ISKP.EQ.0)RETURN
202 A=0
C=1.0
IF(M.LE.0)M=1
DO 1 K=1,M
A=A*10.+IQ(K)
1 IF(K.GT.IDEC)C=C*0.1
JJ=JJ+1
VX(JJ)=A*C*XMINUS
JN=-JN
C SETS IT TO -1 FOR L,R,U,D EDIT ROUTINE
IF(MODE.NE.2)XMINUS=1.
C************: MODE #?
C ONLY ONE '-' NEEDED FOR RHY.COMPOSITE
1310 IF(INP(ML).NE.1)GO TO 310
VX(JJ)=VX(JJ)+1000.
C 1000 IS ADDED FOR EACH DOT. NO MORE COMPOSITES!
ML=ML+1
GO TO 1310
206 ML=ML+2
3310 VX(1)=-99.
310 ISKP=0
IF(N.NE.ISEMI)GO TO 999
RETURN
73 JJ=JJ+1
K=INP(ML)
IF(K.EQ.LEE)GO TO 206
C NEXT IS FOR A REST/R/ OR /RI/ FOR INVIS. REST
CALL RESTIN
GO TO 4410
END
SUBROUTINE RHYLTR
COMMON /ALF/INP(72),ML
COMMON /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX1,VX(49),IAMP,K,RRN,M,MODE,IBLA
C FOR INPUT OF RHYTHM WITH LETTERS - Q=17,E=5,S=19,W=23,G=7,H=8,D=4,T=20
ITRIP=0
444 IF(K.NE.17)GO TO 7444
VX1=4.
GO TO 2444
7444 IF(K.NE.5)GO TO 1444
VX1=8.
GO TO 2444
1444 IF(K.NE.19)GO TO 8444
VX1=16.
GO TO 2444
8444 IF(K.NE.23)GO TO 5444
VX1=1.
GO TO 2444
5444 IF(K.NE.7)GO TO 6444
VX1=88.
GO TO 2444
6444 IF(K.NE.8)GO TO 3444
VX1=2.
GO TO 2444
3444 IF(K.NE.4)GO TO 4444
244 VX1=.5
GO TO 2444
4444 IF(K.NE.20)GO TO 244
C WRONG LETTER WILL DEFAULT TO 'D' DOUBLE WHOLE NOTE
VX1=12.
N=INP(ML)
IF(N.EQ.IBLA)GO TO 2444
IF(N.EQ.JSEMI)GO TO 2444
IF(N.EQ.1)GO TO 2444
C (DOT WAS CHANGED TO 1)
IF(N.EQ.JXX)GO TO 2444
ITRIP=-1
ML=ML+1
K=NALF(N)
N=INP(ML)
GO TO 444
C TS=24TH, TQ=6, TH=3.
C FOR S,E,Q,H,W,D,T RHYTH. 'T'(K=20) =TRIPLET D=DBL WHL NOTE
2444 IF(ITRIP.LT.0)VX1=VX1*1.5
JJ=JJ+1
END
SUBROUTINE RESTIN
C NEXT IS FOR A REST/R/ OR /RI/ FOR INVIS. REST
COMMON /ALF/INP(72),ML
COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
COMMON /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
IF(K.EQ.LDD)GO TO 1073
C /RD/ OR /RU/ = REST 6 DOWN OR 6 UP.
IF(K.EQ.LUU)GO TO 1173
IF(K.EQ.LII)GO TO 573
IF(K.EQ.LWW)GO TO 273
C /RW/ MAKES WHOLE REST REGARDLESS OF TIME VALUE GIVEN.
IF(K.EQ.LRR)GO TO 1273
C /RR/ MAKES REPEAT BAR SIGN (REST=-4)
C ; *** ADD NUMBERS LATER *****; 22932
K=NALF(K)
IF(K.LT.0)GO TO 673
IF(K.GE.10)GO TO 673
973 KV=NALF(INP(ML+1))
C FOR 3-DIG. NUMBS. CAN TAKE NUM UP TO 999 FOR RESTS.
IF(KV.LT.0)GO TO 873
IF(KV.GE.10)GO TO 873
ML=ML+1
K=K*10+KV
C 15 IS K FOR NOW AND K IS IV
GO TO 973
873 QQ=-2000.-QQ
C RW =2002
GO TO 473
673 QQ=2000.
C ORDINARY REST
GO TO 373
573 QQ=2001.
C INVISIBLE REST
GO TO 473
273 QQ=2002.
C WHOLE REST (NO MATTER WHAT RHYTH.)
473 ML=ML+1
373 VX(JJ)=QQ
RETURN
1073 QQ=2004.
C RD = REST DOWN 2004
GO TO 473
1173 QQ=2005.
C RU = REST UP 2005
GO TO 473
1273 QQ=2003.
C RR = BAR REPEAT SIGN
GO TO 473
END
C***** LNEND, BARS, SCAN2, SCAN3, SCAN4
SUBROUTINE LNEND
COMMON/ALF/JNP(72),ML/MKX/LSL
1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
1 /JCHAR/IXX,ISEMI,JBLA,IG
EQUIVALENCE (LST,JALPHA(8)),(LCM,JALPHA(10))
K=1
C IF BAD INPUT PUT ISEMI INTO ALF(4) [JNP1] AT END
C LST * SCX+7
C LCM ;
C LSL /
K3=1
K5=72
2901 IF(LSL.NE.JNP(K3))GO TO 2903
K=K3
GO TO 2902
2903 IF(LCM.NE.JNP(K3))GO TO 2902
JNP(K3)=LST
RETURN
2902 K3=K3+1
IF(K3.LE.K5)GO TO 2901
JNP(K)=LCM
C GET LOC. OF LAST /
END
SUBROUTINE BARS
COMMON /ALF/INP(72),ML /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
C ***** BARS =4000 ****** ; THE 1 IS FOR BAR ONE STAFF ONLY.
QZ=4001.
2002 JN=INP(ML)
IF(JN.EQ.LDD)GO TO 3002
IF(JN.NE.LMM)GO TO 23
VX(1)=VX(1)+1.
ML=ML+1
GO TO 2002
C GO BACK AND LOOK FOR MORE M'S ML=ML+1
3002 ML=ML+1
C FOUND 'MDN' -- FOR DOUBLE BARS
JN=0
QZ=-QZ
C DBL BARS ARE NEG.
23 VX(1)=QZ
K=NALF(INP(ML))
IF(K.LE.0)RETURN
IF(K.GT.9)RETURN
C NO MORE THAN 8 STAVES UP ALLOWED.
K=K-1
C BECAUSE ORIG. NUM WAS 4001, NOT 4000
IF(JN.EQ.0)K=-K
C NEG. IF DBL BAR
VX(1)=VX(1)+K
C 'M2'= A BAR LINE UP 2 STAVES. ETC.
END
SUBROUTINE SCAN2(QZ)
C FOR METER(Tm n), STEM DIR.(SU,SD), STAFF UP-DN
COMMON /ALF/INP(72),ML /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
4 IF(K.NE.20)GO TO 21
QZ=-1
C TRY AGAIN IF NOT A 'T'
IF(INP(ML).GT.0)RETURN
C T12,8/ ETC. MAKES A METR, OR TIM SIG. POS NUMS AREN'T LETRS!
C ***** CLEFS = 3000 ***** CODE 3.
QZ=3000.
IF(INP(ML).EQ.LEE)QZ=QZ+3.
C TENOR CLEF =3003, TREBLE=3000
RETURN
C NOT AN 'S'(STEM OR STAFF), UNKNOWN ITEM, SKIP IT.
21 KI=INP(ML)
C SU UP=5010
QQ=0
IF(KI.EQ.LUU)QQ=10.
IF(KI.EQ.LDD)QQ=20.
C DOWN = 5020
IF(KI.EQ.'+')QQ=2.
C S+=5002
IF(KI.EQ.'-')QQ=1.
C S-=5001
C S0=5000
C THESE ARE FOR S+, S-, S0; PUT NOTE ON OTHER STF.
VX(1)=5000.+QQ
QZ=0
END
SUBROUTINE SCAN3(NSWCH)
C FOR NOTE NAMES.
COMMON /ALF/INP(72),ML /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
6 K=K-2
C -2 BECAUSE MUSICAL ALPHABET STARTS WITH C
IF(K.LE.0)K=K+7
NNUM=K
KQ=1000
K=1
IF(NNUM.GT.3)K=K+1
C FOUND A NOTE
IF(N.EQ.JXX)GO TO 5410
C FOR GX3/ ETC.
IF(N.NE.INP(ML-1))GO TO 66
C NO DOUBLE-LETTER ACCID. (FLAT)
IF(N.NE.INP(ML+1))GO TO 88
C NO TRIPLE-LETTER ACCID. (SHARP)
ML=ML+1
IF(N.NE.INP(ML+1))GO TO 8
C NO TRIPLE-LETTER ACCID. (NATURAL)
ML=ML+1
KQ=1300
C TYPE AA FOR AF, AAA = AS, AAAA = AN
GO TO 610
66 K=NALF(N)
IF(N.GT.0)GO TO 7
C JUMP IF NOT A LETTER
KQ=1300
C ; ***** NOTES ***** =1000 2ND DIG=ACCI.
IF(K.EQ.22)GO TO 610
C *** CAN USE 'V' FOR NATURAL(EASIER TO HIT!!)
IF(K.EQ.14)GO TO 610
C JUMP IF NATURAL
IF(K.EQ.19)GO TO 8
C -- S --
88 KQ=1100
C IT'S A FLAT
GO TO 610
8 KQ=1200
C SHARP =1200
610 ML=ML+1
NK=INP(ML)
K=NALF(NK)
IF(NK.GE.0)GO TO 7
C IF CHAR. ISN'T A LETTER, GO TO S7
C (LETTERS ARE NEG., NUMBS ARE POS.)
IF(K.NE.19)GO TO 777
C IF(K.EQ.19) THEN IT'S SS
C FOR DBL FLAT, DBL SHARP
KQ=1500
C DBL FLAT
GO TO 610
777 IF(K.NE.6)GO TO 7
C IS IT 'FF'?
KQ=1400
C FF=1400, SS=1500
GO TO 610
C GO BACK FOR ANOTHER CHAR.
7 IF(K.EQ.11)GO TO 5410
C IS IT 'K'?
IF(K.LT.0)GO TO 5410
C IF SEMICOLON OR BLANK
IF(K.NE.24)GO TO 24
C IS IT 'X'?
GO TO 5410
24 JSCA=K
C SAVE OCT. NUM
ML=ML+1
GO TO 2410
5410 IF(NSWCH.EQ.0)GO TO 2410
JJ=NOLD-NNUM
IF(JJ.GE.4)JSCA=JSCA+1
IF(JJ.LE.-4)JSCA=JSCA-1
C WILL JUMP TO NEAREST NOTE (DIATONIC-'75)
2410 JJ=1
VX2=0
QQ=JSCA*7+NNUM+KQ
VX(1)=QQ*DBST
C DOUBLE STOPS ARE NEG. NnUMBERS
NOLD=NNUM
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
END
SUBROUTINE SCAN4
C FOR KEY SIGS.
COMMON /ALF/INP(72),ML /SC/J,LSC,MK
1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
QQ=17000.
CC**** NUM FOR KEY SIGS ***
18 N=INP(ML)
ML=ML+1
IF(N.EQ.IBLA)GO TO 18
IF(N.NE.LNN)GO TO 200
C IS IT AN N? K3FN/ OR K2SN/ MAKES NATURALS
C IF NEXT CHAR='N' A 'NATURALS' KEY SIG.
QZ=100.
IF(QQ.LE.0)QZ=-QZ
QQ=QQ+QZ
GO TO 18
200 IF(N.EQ.LSS)GO TO 18
IF(N.EQ.'+')GO TO 18
IF(N.EQ.JSEMI)GO TO 20
IF(N.EQ.'-')N=LFF
IF(N.NE.LFF)GO TO 19
QQ=-QQ
C NEG. FOR FLATS
GO TO 18
19 A=NALF(N)
GO TO 18
C GO BACK AND LOOK AGAIN
20 IF(QQ.LT.0)A=-A
VX(1)=QQ+A
C KSIG
END